home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / lib / xt / context.c < prev    next >
C/C++ Source or Header  |  1992-10-09  |  9KB  |  283 lines
  1. #include "xt.h"
  2.  
  3. static SYMDESCR XtIM_Syms[] = {
  4.     { "x-event",         XtIMXEvent },
  5.     { "timer",           XtIMTimer },
  6.     { "alternate-input", XtIMAlternateInput },
  7.     { 0, 0 }
  8. };
  9.  
  10. static SYMDESCR XtInputMask_Syms[] = {
  11.     { "read",            XtInputReadMask },
  12.     { "write",           XtInputWriteMask },
  13.     { "exception",       XtInputExceptMask },
  14.     { 0, 0 }
  15. };
  16.  
  17. static Object P_Destroy_Context();
  18.  
  19. Generic_Predicate (Context)
  20.  
  21. Generic_Equal (Context, CONTEXT, context)
  22.  
  23. Generic_Print (Context, "#[context %u]", POINTER(x))
  24.  
  25. static Object Internal_Make_Context (finalize, context) XtAppContext context; {
  26.     Object c;
  27.  
  28.     c = Find_Object (T_Context, (GENERIC)0, Match_Xt_Obj, context);
  29.     if (Nullp (c)) {
  30.     c = Alloc_Object (sizeof (struct S_Context), T_Context, 0);
  31.     CONTEXT(c)->tag = Null;
  32.     CONTEXT(c)->context = context;
  33.     CONTEXT(c)->free = 0;
  34.     Register_Object (c, (GENERIC)0,
  35.         finalize ? P_Destroy_Context : (PFO)0, 1);
  36.     XtAppSetWarningHandler (context, Xt_Warning);
  37.     XtAppAddActionHook (context, (XtActionHookProc)Action_Hook,
  38.         (XtPointer)0);
  39.     }
  40.     return c;
  41. }
  42.  
  43. /* Backwards compatibility: */
  44. Object Make_Context (context) XtAppContext context; {
  45.     return Internal_Make_Context (1, context);
  46. }
  47.  
  48. Object Make_Context_Foreign (context) XtAppContext context; {
  49.     return Internal_Make_Context (0, context);
  50. }
  51.  
  52. void Check_Context (c) Object c; {
  53.     Check_Type (c, T_Context);
  54.     if (CONTEXT(c)->free)
  55.     Primitive_Error ("invalid context: ~s", c);
  56. }
  57.  
  58. static Object P_Create_Context () {
  59.     return Make_Context (XtCreateApplicationContext ());
  60. }
  61.  
  62. static Object P_Destroy_Context (c) Object c; {
  63.     Check_Context (c);
  64.     Free_Actions (CONTEXT(c)->context);
  65.     XtDestroyApplicationContext (CONTEXT(c)->context);
  66.     CONTEXT(c)->free = 1;
  67.     Deregister_Object (c);
  68.     return Void;
  69. }
  70.  
  71. static Object P_Initialize_Display (c, d, name, class)
  72.     Object c, d, name, class; {
  73.     register char *sn = 0, *sc = 0, *sd = 0;
  74.     Display *dpy;
  75.     extern char **Argv;
  76.     extern First_Arg, Argc;
  77.     int argc = Argc - First_Arg + 1;
  78.     Declare_C_Strings;
  79.  
  80.     Argv[First_Arg-1] = "elk";
  81.     Check_Context (c);
  82.     if (!EQ(name, False))
  83.     Make_C_String (name, sn);
  84.     if (!EQ(class, False))
  85.     Make_C_String (class, sc);
  86.     if (TYPE(d) == T_Display) {
  87.     XtDisplayInitialize (CONTEXT(c)->context, DISPLAY(d)->dpy,
  88.         sn, sc, (XrmOptionDescRec *)0, 0, &argc, &Argv[First_Arg-1]);
  89.     Argc = First_Arg + argc;
  90.     Dispose_C_Strings;
  91.     return Void;
  92.     }
  93.     if (!EQ(d, False))
  94.     Make_C_String (d, sd);
  95.     dpy = XtOpenDisplay (CONTEXT(c)->context, sd, sn, sc,
  96.     (XrmOptionDescRec *)0, 0, &argc, &Argv[First_Arg-1]);
  97.     Argc = First_Arg + argc - 1;
  98.     if (dpy == 0)
  99.     if (sd)
  100.         Primitive_Error ("cannot open display ~s", d);
  101.     else
  102.         Primitive_Error ("cannot open display");
  103.     Dispose_C_Strings;
  104.     return Make_Display (0, dpy);
  105. }
  106.  
  107. /* Due to a bug in Xt this function drops core when invoked with a
  108.  * display not owned by Xt.
  109.  */
  110. static Object P_Display_To_Context (d) Object d; {
  111.     Check_Type (d, T_Display);
  112.     return
  113.     Make_Context_Foreign (XtDisplayToApplicationContext (DISPLAY(d)->dpy));
  114. }
  115.  
  116. static Object P_Set_Context_Fallback_Resources (argc, argv) Object *argv; {
  117.     register char **p = 0;
  118.     register i;
  119.     struct S_String *sp;
  120.     Object con = argv[0];
  121.  
  122.     Check_Context (con);
  123.     if (argc > 1) {
  124.     argv++; argc--;
  125.     p = (char **)XtMalloc ((argc+1) * sizeof (char *));
  126.     for (i = 0; i < argc; i++) {
  127.         Check_Type (argv[i], T_String);
  128.         sp = STRING(argv[i]);
  129.         p[i] = XtMalloc (sp->size + 1);
  130.         bcopy (sp->data, p[i], sp->size);
  131.         p[i][sp->size] = 0;
  132.     }
  133.     p[i] = 0;
  134.     }
  135.     XtAppSetFallbackResources (CONTEXT(con)->context, p);
  136.     return Void;
  137. }
  138.  
  139. static Object P_Context_Main_Loop (c) Object c; {
  140.     Check_Context (c);
  141.     XtAppMainLoop (CONTEXT(c)->context);
  142.     /*NOTREACHED*/
  143. }
  144.  
  145. static Object P_Context_Pending (c) Object c; {
  146.     Check_Context (c);
  147.     return Bits_To_Symbols ((unsigned long)XtAppPending (CONTEXT(c)->context),
  148.     1, XtIM_Syms);
  149. }
  150.  
  151. static Object P_Context_Process_Event (argc, argv) Object *argv; {
  152.     XtInputMask mask = XtIMAll;
  153.  
  154.     Check_Context (argv[0]);
  155.     if (argc == 2)
  156.     mask = (XtInputMask)Symbols_To_Bits (argv[1], 1, XtIM_Syms);
  157.     XtAppProcessEvent (CONTEXT(argv[0])->context, mask);
  158.     return Void;
  159. }
  160.  
  161. static Boolean Work_Proc (client_data) XtPointer client_data; {
  162.     Object ret = Funcall (Get_Function ((int)client_data), Null, 0);
  163.     if (Truep (ret))
  164.     Deregister_Function ((int)client_data);
  165.     return Truep (ret);
  166. }
  167.  
  168. static Object P_Context_Add_Work_Proc (c, p) Object c, p; {
  169.     XtWorkProcId id;
  170.     register i;
  171.  
  172.     Check_Context (c);
  173.     Check_Procedure (p);
  174.     i = Register_Function (p);
  175.     id = XtAppAddWorkProc (CONTEXT(c)->context, Work_Proc, (XtPointer)i);
  176.     return Make_Id ('w', (XtPointer)id, i);
  177. }
  178.  
  179. static Object P_Remove_Work_Proc (id) Object id; {
  180.     XtRemoveWorkProc ((XtWorkProcId)Use_Id (id, 'w'));
  181.     Deregister_Function (IDENTIFIER(id)->num);
  182.     return Void;
  183. }
  184.  
  185. static void Timeout_Proc (client_data, id)
  186.     XtPointer client_data; XtIntervalId *id; {
  187.     Object proc, args;
  188.     register i = (int)client_data;
  189.  
  190.     args = Cons (Make_Id ('t', (XtPointer)*id, i), Null);
  191.     proc = Get_Function (i);
  192.     Deregister_Function (i);
  193.     (void)Funcall (proc, args, 0);
  194. }
  195.  
  196. static Object P_Context_Add_Timeout (c, n, p) Object c, n, p; {
  197.     XtIntervalId id;
  198.     register i;
  199.  
  200.     Check_Context (c);
  201.     Check_Procedure (p);
  202.     i = Register_Function (p);
  203.     id = XtAppAddTimeOut (CONTEXT(c)->context, Get_Integer (n), Timeout_Proc,
  204.     (XtPointer)i);
  205.     return Make_Id ('t', (XtPointer)id, i);
  206. }
  207.  
  208. static Object P_Remove_Timeout (id) Object id; {
  209.     XtRemoveTimeOut ((XtIntervalId)Use_Id (id, 't'));
  210.     Deregister_Function (IDENTIFIER(id)->num);
  211.     return Void;
  212. }
  213.  
  214. /*ARGSUSED*/
  215. static void Input_Proc (client_data, src, id) XtPointer client_data; int *src;
  216.     XtInputId *id; {
  217.     Object p, args;
  218.     GC_Node2;
  219.  
  220.     p = Get_Function ((int)client_data);
  221.     args = Null;
  222.     GC_Link2 (p, args);
  223.     args = Cons (Make_Id ('i', (XtPointer)*id, (int)client_data), Null);
  224.     args = Cons (Car (p), args);
  225.     GC_Unlink;
  226.     (void)Funcall (Cdr (p), args, 0);
  227. }
  228.  
  229. static Object P_Context_Add_Input (argc, argv) Object *argv; {
  230.     Object c = argv[0], src = argv[1], p = argv[2];
  231.     XtInputId id;
  232.     XtInputMask m;
  233.     register i;
  234.  
  235.     Check_Context (c);
  236.     Check_Procedure (p);
  237.     Check_Type (src, T_Port);
  238.     if (!(PORT(src)->flags & P_OPEN))
  239.     Primitive_Error ("port has been closed: ~s", src);
  240.     if (PORT(src)->flags & P_STRING)
  241.     Primitive_Error ("invalid port: ~s", src);
  242.     if (argc == 4) {
  243.     m = Symbols_To_Bits (argv[3], 1, XtInputMask_Syms);
  244.     } else {
  245.     switch (PORT(src)->flags) {
  246.     case 0:       m = XtInputWriteMask;                 break;
  247.     case P_INPUT: m = XtInputReadMask;                  break;
  248.     default:      m = XtInputReadMask|XtInputWriteMask; break;
  249.     }
  250.     }
  251.     i = Register_Function (Cons (src, p));
  252.     id = XtAppAddInput (CONTEXT(c)->context, fileno (PORT(src)->file),
  253.     (XtPointer)m, Input_Proc, (XtPointer)i);
  254.     return Make_Id ('i', (XtPointer)id, i);
  255. }
  256.  
  257. static Object P_Remove_Input (id) Object id; {
  258.     XtRemoveInput ((XtInputId)Use_Id (id, 'i'));
  259.     Deregister_Function (IDENTIFIER(id)->num);
  260.     return Void;
  261. }
  262.  
  263. init_xt_context () {
  264.     Generic_Define (Context, "context", "context?");
  265.     Define_Primitive (P_Create_Context,     "create-context",     0, 0, EVAL);
  266.     Define_Primitive (P_Destroy_Context,    "destroy-context",    1, 1, EVAL);
  267.     Define_Primitive (P_Initialize_Display, "initialize-display", 4, 4, EVAL);
  268.     Define_Primitive (P_Display_To_Context, "display->context",   1, 1, EVAL);
  269.     Define_Primitive (P_Set_Context_Fallback_Resources,
  270.             "set-context-fallback-resources!",   1, MANY, VARARGS);
  271.     Define_Primitive (P_Context_Main_Loop,  "context-main-loop",  1, 1, EVAL);
  272.     Define_Primitive (P_Context_Pending,    "context-pending",    1, 1, EVAL);
  273.     Define_Primitive (P_Context_Process_Event,
  274.             "context-process-event",                1, 2, VARARGS);
  275.     Define_Primitive (P_Context_Add_Work_Proc,
  276.             "context-add-work-proc",                  2, 2, EVAL);
  277.     Define_Primitive (P_Remove_Work_Proc,   "remove-work-proc",   1, 1, EVAL);
  278.     Define_Primitive (P_Context_Add_Timeout,"context-add-timeout",3, 3, EVAL);
  279.     Define_Primitive (P_Remove_Timeout,     "remove-timeout",     1, 1, EVAL);
  280.     Define_Primitive (P_Context_Add_Input,  "context-add-input",3, 4, VARARGS);
  281.     Define_Primitive (P_Remove_Input,       "remove-input",       1, 1, EVAL);
  282. }
  283.